COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00005 00003
C00013 00004
C00015 00005
C00018 00006
C00021 00007
C00023 ENDMK
C⊗;

;;;   ***********************************************************************
;;;   ***** Maclisp ****** S-expression formatter for files (grind) *********
;;;   ***********************************************************************
;;;   ** (c) Copyright 1976 Massachusetts Institute of Technology ***********
;;;   ****** this is a read-only file! (all writes reserved) ****************
;;;   ***********************************************************************
;;;This version of Grind works in both ITS Maclisp and Multics Maclisp
;;;GFILE - fns for pretty-printing and grinding files.
(and (not (status feature sail))
     (progn
      (putprop 'eread (get 'uread 'fsubr) 'fsubr) 
      (putprop 'urename (get 'ufile 'fsubr) 'fsubr)))

(declare (array* (notype (gtab/| 128.)))
	 (noargs t)
	 (special merge readtable grindreadtable remsemi ~r
		  grindpredict grindproperties grindef predict
		  grindfn grindmacro programspace topwidth niop/|
		  grindlinct global-lincnt /; /;/; user-paging form
		  prog? n m l h arg linel pagewidth gap comspace
		  fill nomerge comnt /;/;? ↑d macro unbnd-vrbl
		  cnvrgrindflag outfiles infile stringp)
	 (*expr form topwidth programspace pagewidth comspace
		nomerge remsemi stringp)
	 (*fexpr trace slashify unslashify grindfn grindmacro
		 unreadmacro readmacro grindef)
	 (*lexpr merge predict user-paging fill testl)
	 (mapex t)
	 (genprefix gr+)
	 (fixnum nn
		 mm
		 (grchrct)
		 (newlinel-set fixnum)
		 (prog-predict notype fixnum fixnum)
		 (block-predict notype fixnum fixnum)
		 (setq-predict notype fixnum fixnum)
		 (panmax notype fixnum fixnum)
		 (maxpan notype fixnum fixnum)
		 (gflatsize))
	 (mapc  '(lambda (data) (args data nil))
		'(print princ tyi tyipeek read readch))) 

(defun macex macro (x) 
       (list 'defun
	     (cadr x)
	     'macro
	     (caddr x)
	     (eval (cadddr x)))) 


(macex newlineseq (x) 
       (cond ((status feature multics)
	      ''(list (ascii 10.)))
	     (t ''(list (ascii 13.) (ascii 10.))))) 

(macex version (x) 
       (subst (maknam (nconc (newlineseq)
			     (explodec '/;loading/ grind/ )
			     (explodec (cond ((status feature newio)
					      (caddr (truename infile)))
					     ((cadr (status uread)))))
			     (newlineseq)))
	      'version
	      ''(or (status feature noldmsg)
		    ((lambda (↑w ↑q ↑r)
			     (princ 'version)
			     (ascii 0.))
		     nil
		     nil
		     nil))))

(version)
 



(prog nil 							       ;some initializations
      (setq niop/| (status feature newio))
      (and (not (boundp 'grind-use-original-readtable))
	   (setq grind-use-original-readtable t))
      (and (or (not (boundp 'grindreadtable))			       ;readtable (default).
	       (null grindreadtable))
	   ((lambda (readtable) (setsyntax 12. 'single nil)	       ;↑l made noticeable.
				(and (not niop/|) (sstatus terpri t))      ;the grindreadtable is tailored for
				(setsyntax '/;			       ;grind. no cr
					   'splicing
					   'semi-comment))	       ;are inserted by lisp when print exceeds
	    (setq grindreadtable
		  (*array nil
			  'readtable
			  grind-use-original-readtable))))
      (setq macro '/; 
	    /; (copysymbol '/; nil) 
	    /;/; (copysymbol '/;/; nil))
      (setq grindlinct 8. global-lincnt 59. comnt nil /;/;? nil)
      (setq stringp (status feature string))
      (putprop 'lap-grind (cons 'grilap (cdr (get 'grind 'autoload))) 'autoload))
 


(defun grind fexpr (file) 				                ;grinds and files file.
      ((lambda (x) 
	  (cond ((and stringp (stringp (car file))))	;already filed.
		((apply 'urename x)))
	   file)
	 (apply 'grind0 (cond ((status feature sail)	
			       (cond 
				((and (cadr file)(not (eq (cadr file) 'dsk))) file)
	      (t (append (list (car file) '/ )(cdr file)))))))
))) 

 (defun grind0 fexpr (file) 					       ;grinds file and returns file
	      (or (status feature grindef)
		  (cond (niop/| (load (get 'grindef 'autoload)))
			(t ((lambda (eof)
				    (apply 'fasload (get 'grindef 'autoload))
				    (apply 'crunit eof))
				(crunit)))))
	(prog (remsemi linel *nopoint readtable base l ↑q ↑r ↑w ↑d     ;programspace.
	       outfiles eof n /;/;? comnt) 
	      (setq base 10. linel programspace 
		    readtable grindreadtable remsemi t)
	      (cond
	       ((and stringp (stringp (car file)))
		(inpush (openi (car file)))
		(setq 
		 outfiles
		 (list
		  (openo
		   (mergef
		    (cond ((null (cdr file))
			   (princ '|
filing as !grind.output
|				  nil)
			   '(* /!grind output))
			  ((cadr file)))
		    (cons (car (namelist nil)) '*)
		    (namelist infile))))))
	       (t (apply 'eread file) (uwrite)))
	      (setq eof (list nil) n topwidth)
	      (setq ↑q t ↑r t ↑w t grindlinct global-lincnt)
	 read (and (= (cond (niop/| (tyipeek 47791616. -1))
			    ((tyipeek 47791616.))) 
		      59.)			  ;catch top-level splicing macro
		   (readch)
		   (cond ((eq (car (setq l (car (semi-comment)))) /;)
			  (rem/;)
			  (go read))
			 (t (go read1))))
	      (and (null ↑q) (setq l eof) (go read1))		       ;catch eof in tyipeek
	      (and (eq (car (setq l (read eof))) /;)		       ;store /; strings of /; comments.
		   (rem/;)
		   (go read))
	 read1(prinallcmnt)					       ;print stored /; comments
	      (or (eq eof l) (go process))
	 exit (terpri)
	      (setq ~r nil)
	      (and stringp 
		   (stringp (car file))
		   (close (car outfiles)))			       ;won't get ufile'd
	      (return file)
	 process
	      (cond ((eq l (ascii 12.))				       ;formfeed read in ppage mode
		     (or user-paging (go read))			       ;ignore ↑l except in user-paging mode.
		     (and (cond (niop/| (< (tyipeek 50167296. -1) 0))				      ((= (tyipeek t) 3.)))
			  (go exit))					;any non-trivial characters before eof?
		     (terpri)
		     (page)
		     (setq /;/;? t)
		     (go read))
		    ((eq (car l) /;/;)				       ;toplevel ;;... comment
		     (newlinel-set topwidth)
		     (or /;/;? (= linel (grchrct)) (turpri) (turpri))  ;produces  blank line preceding new
		     (rem/;/;)					       ;block of /;/; comments. (turpri is
		     (newlinel-set programspace)		       ;already in rem/;/;).  a total of 3
		     (go read)))				       ;turpri's are necessary if initially
	      (fillarray 'gtab/| '(nil))				       ;chrct is not linel, ie we have just
	      (cond (user-paging (turpri) (turpri))		       ;finished a line and have not yet cr.
		    ((< (turpri)
			(catch (\ (panmax l (grchrct) 0.) 60.)))       ;clear hash array
		     (page))
		    ((turpri)))
	      (cond ((eq (car l) 'lap) (lap-grind))
		    ((sprint1 l linel 0.) (prin1 l)))
	      (tyo 32.)							 ;prevents toplevel atoms from being
	      (go read))) 					       ;accidentally merged by being separated only by
								       ;cr.


(defun newlinel-set (x) 
    (setq chrct (+ chrct (- x linel))
	  linel x))

(putprop /; '(lambda (l n m) 0.) 'grindpredict) 

(putprop /;/; '(lambda (l n m) 1.) 'grindpredict) 

;;semi-colon comments

(defun rem/; nil 
       (prog (c retval) 
	a    (cond ((atom l) (return retval))
		   ((eq (car l) /;)
		    (setq c (cdr l))
		    (setq retval 'car)
		    (setq l nil))
		   ((and (null (atom (car l))) (eq (caar l) /;))
		    (setq c (cdar l))
		    (setq retval 'caar)
		    (setq l (cdr l)))
		   (t (cond ((and (eq retval 'caar)		       ;look ahead to separate comments.
				  (cdr l)
				  (null (atom (cdr l)))
				  (null (atom (cadr l)))
				  (eq (caadr l) /;))
			     (prinallcmnt)
			     (indent-to n)))
		      (return retval)))
	b    (cond ((null comnt) (setq comnt c))
		   ((< comspace (length comnt)) (turpri) (go b))
		   ((nconc comnt (cons '/  c))))
	     (go a))) 


(defun rem/;/; nil 
       (prog (c retval) 
	a    (cond ((atom l)
		    (and (eq retval 'caar) (indent-to n))
		    (return retval))
		   ((eq (car l) /;/;)
		    (setq c (cdr l))
		    (setq retval 'car)
		    (setq l nil))
		   ((and (null (atom (car l))) (eq (caar l) /;/;))
		    (setq c (cdar l))
		    (setq retval 'caar)
		    (setq l (cdr l)))
		   (t (and (eq retval 'caar) (indent-to n))	       ;restore indentation for upcoming code
		      (return retval)))
	     (prinallcmnt)
	     (and (null /;/;?) (turpri))
	     (prog (comnt pagewidth comspace macro) 
		   (setq comnt c)
		   (and (or (memq (car c) '(/; *))
			    (null merge))			       ;nomerge.  update pagewidth, comspace
			(setq /;/;? '/;/;/;)			       ;appropriate for a total line of
			(setq pagewidth topwidth 		       ;topwidth
			      comspace (+ n (- topwidth linel)))
			(go prinall))
		   (setq pagewidth linel)
		   (cond ((eq /;/;? /;/;)			       ;preceding comnt.  merge.
			  (setq comnt (cons '/  comnt))
			  (setq macro (ascii 0.))
			  (setq comspace (grchrct))
			  (prin50com))
			 ((setq /;/;? /;/;)))
		   (setq comspace n)
	      prinall
		   (setq macro /;/;)
		   (prinallcmnt))
	     (tj6 c)
	     (go a))) 

(defun tj6 (x) 							       ;tj6 commands: ;;*--- or ;;*(...) (...)
       (and
	(eq (car x) '*)
	(setq x (cdr x))
	(turpri)
	(cond
	 ((errset
	   (cond ((atom (car (setq x
				   (readlist (cons '/(
						   (nconc x
							  '(/))))))))
		  (eval x))
		 ((mapc 'eval x)))))
	 ((error '/;/;*/ error x 11.))))) 


(defun prin50com nil 						       ;prints one line of ; comment
       (prog (next)
	   (newlinel-set pagewidth)				       ;update linel, chrct for space of pagewidth.
	   (prog (comnt) (indent-to comspace))
	   (princ macro)
	   pl
	   (cond ((null comnt) (return nil))
		 ((eq (car comnt) '/ )
		  (setq comnt (cdr comnt))
		  (setq next
			(do ((x comnt (cdr x)) (num 2. (1+ num)))      ;number of characters till next space.
			    ((or (null x) (eq (car x) '/ ))
			     num)))
		  (cond ((and (or (eq macro /;) (eq /;/;? /;/;))
			      fill
			      (= next 2.)
			      (go pl)))
			((and (not (eq macro (ascii 0.)))
			      (> next comspace)))
			((< (grchrct) next) (return nil)))
		  (tyo 32.)
		  (go pl))
		 ((> (grchrct) 0.)
		  (princ (car comnt))
		  (and (or (eq macro /;) (eq /;/;? /;/;))
		       fill
		       (eq (car comnt) '/.)
		       (eq (cadr comnt) '/ )
		       (tyo 32.)))
		 (t (return nil)))
	   (setq comnt (cdr comnt))
	   (go pl))
		(newlinel-set programspace)) 		       ;may restore chrct to be negative.

(defun prinallcmnt nil (cond (comnt (prin50com) (prinallcmnt))))       ;prints \ of ; comment

(defun semi-comment nil 					       ;converts ; and ;; comments to exploded
       (prog (com last char) 					       ;lists
	     (setq com (cons /; nil) last com)
	     (setq char (readch))				       ;decide type of semi comment
	     (cond ((eq char '/
) (return (list com)))
		   ((eq char '/;) (rplaca last /;/;))
		   ((rplacd last (cons char nil))
		    (setq last (cdr last))))
	a    (setq char (readch))
	     (cond ((eq char '/
) (return (list com)))
		   ((rplacd last (cons char nil))
		    (setq last (cdr last))
		    (go a))))) 


(defun grindcolmac nil (list ': (read))) 

(defun grindcommac nil (list '/, (read))) 

(defun grindatmac nil (cons '@ (read))) 

(defun grindexmac nil 
       (prog (c f) 
	     (setq c (grindnxtchr))
	ta   (cond ((setq f (assq c '((" /!") (@ /!@) ($ /!$))))
		    (tyi)
		    (return (cons (cadr f) (read))))
		   ((setq f (assq c
				  '((? /!?) (/' /!/') (> /!>) (/, /!/,)
				    (< /!<) (/; /!/;))))
		    (tyi)
		    (setq f (cadr f)))
		   (t (setq c (error 'bad/ /!/ macro
				     c
				     'wrng-type-arg))
		      (go ta)))
	     (return (cond ((grindseparator (grindnxtchr))
			    (list f nil))
			   ((atom (setq c (read))) (list f c))
			   (t (cons f c)))))) 

(defun grindnxtchr nil (ascii (tyipeek))) 

(defun grindseparator (char) (memq char '(/  /  /)))) 

(sstatus feature grind)